Proyecto - Contingencias de Vida II

Librerías e importaciones

source("cod/setup.R")
source("cod/load_database.R")
source("cod/prob_estim.R")

Factor de degradación para estados CAR

La metodología original empezaba a dar problemas con probabilidades negativas a partir de una edad aproximada de 95 años, por lo que se decidió implementar un factor de reducción desde los 90 años para primero, complementar la probabilidad creciente de muerte y además poder arreglar el problema de probabilidades negativas.

Empezar las tablas

source("cod/tablas.R")
Males <- tablas(1)
Females <- tablas(2)

Mejora de mortalidades en el tiempo y mejora de transiciones de empeoramiento

source("cod/degradar_mort.R")
edad20 <- degradar_mort(20, 1)

Diseño del producto

Pago de primas: anual Esto se justifica con las probabilidades de transición de un año Temporalidad del seguro: vitalicio Es un seguro LTC, por lo que esperamos a que el asegurado tenga varios estados antes de morir. Si no fuera vitalicio, dejaríamos a medias a un asegurado. Temporalidad de pago de primas: hasta entrar en los estados severe/profound

Inflación: 3% Caso pesimista: 8% Caso optimista: -1%

Tasa de interés: 5% Caso pesimista: 3% Caso optimista: 6.5%

calculo_acumulado <- function(x, tables){
  # Por si acaso, estados termina en 000001 porque multiplicamos todas las transiciones
  t1 <- tables$Able %>% select(-x) 
  t2 <- tables$Mild %>% select(-x) 
  t3 <- tables$Moderate %>% select(-x)
  t4 <- tables$Severe %>% select(-x)
  t5 <- tables$Profound %>% select(-x)
  estados <- as.numeric(t1[1,])
  suma <- estados
  for(i in 2:(120-x)){
    matriz_t <- rbind(t1[i,], t2[i,], t3[i,], t4[i,], t5[i,], c(0,0,0,0,0,1)) 
    matriz_t <- as.matrix(matriz_t)
    estados <- estados %*% matriz_t
    suma <- suma + estados
  }
  return(suma)
}
calculo_acumulado(20, edad20)
##          Able     Mild Moderate   Severe Profound     Dead
## [1,] 47.37181 6.189344 3.146311 2.592936 3.691732 37.00786
edad20sin_m <- lapply(Males, function(x) as.data.frame(x[21:120,]))
calculo_acumulado(20, edad20sin_m)
##          Able    Mild Moderate  Severe Profound    Dead
## [1,] 42.42809 5.49957 2.619793 1.85696 2.063781 45.5318

Hay una clara diferencia entre mejorías de mortalidades

rm(
  add_mort,
  deteriorate,
  degradacion,
  prob,
  readdata,
  red_factor_norm,
  tablas,
  fig,
  edad20sin_m
)

Cálculo de valores presentes

calculo_vp <- function(x, tables, interes, inflacion){
  # Por si acaso, termina en 000001 porque estamos multiplicando todas las transiciones
  v <- (1+inflacion)/(1+interes)
  t1 <- tables$Able %>% select(-x)
  t2 <- tables$Mild %>% select(-x) 
  t3 <- tables$Moderate %>% select(-x)
  t4 <- tables$Severe %>% select(-x)
  t5 <- tables$Profound %>% select(-x)
  estados <- as.numeric(t1[1,])
  suma <- estados
  seguro <- 0
  for(i in 2:(120-x)){
    matriz_t <- rbind(t1[i,], t2[i,], t3[i,], t4[i,], t5[i,], c(0,0,0,0,0,1)) 
    matriz_t <- as.matrix(matriz_t)
    temp <- estados %*% matriz_t
    
    # Personalizable según el tipo de desembolso/prima
    seguro <- seguro  + (temp[6]- estados[6])*v^i
    estados <- temp
    suma <- suma + estados*v^(i-1)
  }
  suma[6] <- seguro
  return(suma)
}
prueba <- calculo_vp(20, edad20, 0.07, 0.03)

# Seguro de vida normal, 100 millones
(prueba[6]*100e6 )/(12*prueba[1])
## [1] 40566.81
# Seguro de vida con anualidades en caso de Severe o Profound, pagando Mild y Moderate
(prueba[6]*100e6 + 12*(1.5e6*prueba[4] + 3e6*prueba[5])  )/(12*(prueba[1]+prueba[2]+prueba[3]))
## [1] 131250.8
# Seguro de vida con anualidades pagando 0.25e6 en aumento de estado
(prueba[6]*100e6 + 12*(0.25e6*prueba[2] +
                         0.5e6*prueba[3] +
                         0.75e6*prueba[4] +
                         1e6*prueba[5]))/(12*prueba[1])
## [1] 111972.8
# Seguro de vida con anualidades pagando 0.5e6 en aumento de estado
(prueba[6]*100e6 + 12*(0.5e6*prueba[2] +
                         1e6*prueba[3] +
                         1.5e6*prueba[4] +
                         2e6*prueba[5]))/(12*prueba[1])
## [1] 183378.8
rm(
  edad20, 
  prueba,
  calculo_acumulado,
  calculo_vp
)

Modelo estocástico

Generación del portafolio

set.seed(70707)
portfolio <- data.frame(edad = round(runif(5000, 19.5, 70.5)),
                         sexo = round(runif(5000, 1, 2))) %>% 
  arrange(., edad, sexo) %>%
  mutate(id = dense_rank(paste(edad, sexo)))
descripcion <- portfolio %>% count(edad, sexo)
lista <- list()
for(i in 1:length(descripcion$edad)) {
  prob_matrices <- degradar_mort(descripcion$edad[i], descripcion$sexo[i])
  
  # Aplicar `cumsum` a cada dataframe dentro de `prob_matrices` (uno por estado)
  lista[[i]] <- lapply(prob_matrices, function(df) {
    t(apply(df[, 2:7], 1, cumsum))
  })
}
rm(
  degradar_mort,
  red_factor_mort,
  red_factor_rest
)

Proyección de primas

Esto es extra, no se piden.

source("cod/proy_prima.R")
t <- proc.time()
proy_prima_data <- proy_prima_par(10, 0.07, 0.03)
proc.time()-t
##    user  system elapsed 
##    0.00    0.11    0.92

Preparación para modelar estocásticamente

Variables globales

interes <- 0.07
inflacion <- 0.03
edades <- portfolio$edad
rango <- 120 - min(edades)
v <- (1 + inflacion) / (1 + interes)
v_power <- v^(0:rango)
mujeres <- sum(portfolio$sexo == 2)
hombres <- sum(portfolio$sexo == 1)
sexos <- portfolio$sexo == 1
variables <- c("lista",
                "portfolio",
                "sexos",
                "hombres",
                "mujeres",
                "rango",
                "v_power",
                "proyeccion")

Funciones

source("cod/proyecciones.R")

Proyeccion grupal de pagos y vivos

Única

set.seed(1)
t <- proc.time()
prueba <- proyeccion()
proc.time()-t
##    user  system elapsed 
##    1.03    0.02    1.94

Varias

set.seed(1)
t <- proc.time()
prueba_gr <- list()
for(i in 1:10){
  prueba_gr[[i]] <- proyeccion()
}
proc.time()-t
##    user  system elapsed 
##   18.31    0.17   37.84

Paralelizado

t <- proc.time()
proyeccion_data <- proyeccion_par(100, cores = 4)
proc.time()-t
##    user  system elapsed 
##    0.05    0.09  116.08

Resumen estocástico

Esperanza

source("cod/resumen_estoc.R")
t <- proc.time()
media <- esperanza(proyeccion_data)
proc.time()-t
##    user  system elapsed 
##    0.27    0.00    0.53

Percentil

t <- proc.time()
percent.995 <- perc_0_995(proyeccion_data)
proc.time()-t
##    user  system elapsed 
##    0.38    0.00    0.92

Gráficos